home *** CD-ROM | disk | FTP | other *** search
/ MacTech 1 to 12 / MacTech-vol-1-12.toast / Source / MacTech® Magazine / Volume 07 - 1991 / 07.10 Oct 91 / facts code
Encoding:
Text File  |  1990-03-11  |  2.3 KB  |  121 lines  |  [TEXT/EDIT]
  1. ; File:  fact.y.
  2.  
  3. ; Here's the chosen function.
  4.  
  5. (define fact 
  6.   (lambda (n)
  7.     (if (zero? n)
  8.         1
  9.         (* n (fact (- n 1))))))
  10. ;
  11. (fact 5)
  12. ;
  13. (define identity
  14.   (lambda (x) x))
  15. ;
  16. (define project-1st-of-2
  17.   (lambda (x)
  18.     (lambda (y)
  19.       x)))
  20. ;
  21. (define project-2nd-of-2
  22.   (lambda (x)
  23.     identity))
  24. ;
  25. (define project-3rd-of-3
  26.   (lambda (x)
  27.     (lambda (y)
  28.       identity)))
  29. ;
  30. (define combinator-true
  31.   project-1st-of-2)
  32. ;
  33. (define combinator-false
  34.   project-2nd-of-2)
  35. ;
  36. (define combinator-cons
  37.   (lambda (x)
  38.     (lambda (y)
  39.       (lambda (selector)
  40.         ((selector x) y)))))
  41. ;
  42. (define combinator-car
  43.   (lambda (object)
  44.     (object project-1st-of-2)))
  45. ;
  46. (define combinator-cdr
  47.   (lambda (object)
  48.     (object project-2nd-of-2)))
  49. ;
  50. (define force-a-thunk
  51.   (lambda (thunk)
  52.     (thunk)))
  53. ;
  54. (define combinator-if
  55.   (lambda (condition)
  56.     (lambda (then)
  57.       (lambda (else)
  58.         (force-a-thunk ((condition then) else))))))
  59. ;
  60. (define combinator-zero
  61.   project-2nd-of-2)
  62. ;
  63. (define combinator-zero?
  64.   (lambda (n)
  65.     ((n project-3rd-of-3) combinator-true)))
  66. ;
  67. (define combinator-succ
  68.   (lambda (n)
  69.     (lambda (f)
  70.       (lambda (x)
  71.         (f ((n f) x))))))
  72. ;
  73. (define dechurchify-numeral
  74.   (lambda (numeral)
  75.     ((numeral 1+) 0)))
  76. ;
  77. (define make-church-numeral
  78.   (lambda (n)
  79.     (if (zero? n)
  80.         combinator-zero
  81.         (combinator-succ 
  82.          (make-church-numeral (- n 1))))))
  83. ;
  84. (define combinator-*
  85.   (lambda (m)
  86.     (lambda (n)
  87.       (lambda (f)
  88.         (m (n f))))))
  89. ;
  90. (define combinator-pred
  91.   (lambda (n)
  92.     (combinator-car 
  93.      ((n (lambda (tuple)
  94.            ((combinator-cons 
  95.              (combinator-cdr tuple))
  96.             (combinator-succ (combinator-cdr tuple)))))
  97.       ((combinator-cons "combinator-pred called on 0")
  98.        combinator-zero)))))
  99. ;
  100. (define combinator-applicative-order-y
  101.   (lambda (f)
  102.     ((lambda (x) (f (lambda (arg) ((x x) arg))))
  103.      (lambda (x) (f (lambda (arg) ((x x) arg)))))))
  104. ; 
  105. (define combinator-one
  106.   (make-church-numeral 1))
  107. ;
  108. (define combinator-fact
  109.   (combinator-applicative-order-y 
  110.    (lambda (fact)
  111.      (lambda (n)
  112.        (((combinator-if (combinator-zero? n))
  113.          (lambda () combinator-one))
  114.         (lambda () ((combinator-* n) 
  115.                     (fact (combinator-pred n)))))))))
  116. ;
  117. (dechurchify-numeral 
  118.  (combinator-fact (make-church-numeral 5)))
  119. ;
  120. ; Done.
  121.